COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	             -*- Mode:LISP Package:MACSYMA -*-                       
C00010 00003
C00020 00004
C00022 00005
C00023 ENDMK
C⊗;
;;;             -*- Mode:LISP; Package:MACSYMA -*-                       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;            Please do not modify this file.  See MRG.                 ;;;
;;;       (c) Copyright 1979 Massachusetts Institute of Technology       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(herald "MACROS" "")
(DECLARE (MACROS T))

(EVAL-WHEN (COMPILE LOAD EVAL) (SETSYNTAX '/# 'MACRO 'TYI))

(EVAL-WHEN (COMPILE LOAD EVAL)
  (SETSYNTAX '/: 'MACRO
    '(LAMBDA () (DO ((L (LIST (READ)) (CONS (READ) L)))
		    ((NOT (= #: (TYIPEEK))) (CONS 'SEL (NREVERSE L)))
		    (TYI))))

  (SETSYNTAX '/< 'MACRO
    '(LAMBDA () (COND ((= #  (TYIPEEK)) '|<|)
		      ((= #= (TYIPEEK)) (TYI) '|<=|)
		      (T (DO ((S (READ) (READ)) (NL))
			     ((EQ '/> S) (CONS 'SELECTOR (NREVERSE NL)))
			     (SETQ NL (CONS S NL)))))))

  (SETSYNTAX '/> 'MACRO
    '(LAMBDA () (COND ((NOT (= #= (TYIPEEK))) '/>)
		      (T (TYI) '|>=|))))
) ;End of EVAL-WHEN

(setq ibase 10. base 10.)

(DEFUN DEFINE-MACRO (NAME LAMBDA-EXP)
    (PUTPROP NAME LAMBDA-EXP 'MACRO))

(DEFUN LAMBIND MACRO (X)
  (DO ((L (CADR X) (CDR L)) (NL) (VL))
      ((NULL L)
       (SETQ VL (NREVERSE VL) NL (NREVERSE NL))
       `((LAMBDA ,VL . ,(CDDR X)) . ,NL))
      (COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
	    (T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))

(DEFUN LAMBIND* MACRO (X)
  (DO ((L (CADR X) (CDR L)) (NL) (VL))
      ((NULL L)
       (SETQ VL (NREVERSE VL) NL (NREVERSE NL))
       `((LAMBDA ,VL (PROG NIL . ,(CDDR X))) . ,NL))
      (COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
	    (T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))

(DEFUN PROGB MACRO (X)
  (DO ((L (CADR X) (CDR L)) (NL) (VL))
      ((NULL L)
       (SETQ VL (NREVERSE VL) NL (NREVERSE NL))
       `((LAMBDA ,VL . ,(CDDR X)) . ,NL))
      (COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
	    (T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))

(DEFUN PROGB* MACRO (X)
  (DO ((L (CADR X) (CDR L)) (NL) (VL))
      ((NULL L)
       (SETQ VL (NREVERSE VL) NL (NREVERSE NL))
       `((LAMBDA ,VL (PROG NIL . ,(CDDR X))) . ,NL))
      (COND ((ATOM (CAR L)) (SETQ VL (CONS (CAR L) VL) NL (CONS NIL NL)))
	    (T (SETQ VL (CONS (CAAR L) VL) NL (CONS (CADAR L) NL))))))

(DEFUN MAPAND MACRO (X)
  `(DO ((L ,(CADDR X) (CDR L))) ((NULL L) T)
       (IFN (,(CADR X) (CAR L)) (RETURN NIL))))

(DEFUN MAPAND2 MACRO (X)
  `(DO ((L ,(CADDR X) (CDR L)) (M ,(CADDDR X) (CDR M)))
       ((NULL L) T)
       (IFN (,(CADR X) (CAR L) (CAR M)) (RETURN NIL))))

(DEFUN MAPOR MACRO (X)
  `(DO ((L ,(CADDR X) (CDR L)) (dum)) ((NULL L))
       (IF (setq dum (FUNCALL ,(CADR X) (CAR L))) (RETURN dum))))

(DEFUN MAPLAC MACRO (X)
  `(DO L ,(CADDR X) (CDR L) (NULL L) (RPLACA L (,(CADR X) (CAR L)))))

(DEFUN IF MACRO (X)
  (COND ((NULL (CDDDR X)) `(COND (,(CADR X) ,(CADDR X))))
	(T `(COND (,(CADR X) ,(CADDR X)) (T . ,(CDDDR X))))))

(DEFUN IFN MACRO (X)
  (COND ((NULL (CDDDR X)) `(COND ((NOT ,(CADR X)) ,(CADDR X))))
	(T `(COND ((NOT ,(CADR X)) ,(CADDR X)) (T . ,(CDDDR X))))))

(DEFUN PUT MACRO (X) `(PUTPROP . ,(CDR X)))
(DEFUN REM MACRO (X) `(REMPROP . ,(CDR X)))

(DEFUN IAND MACRO (X) `(BOOLE 1 . ,(CDR X)))
(DEFUN IOR MACRO (X) `(BOOLE 7 . ,(CDR X)))

(DEFUN XOR MACRO (X) `(NOT (EQ . ,(CDR X))))

(DEFUN COPY MACRO (X) `(SUBST NIL NIL ,(CADR X)))
(DEFUN COPYP MACRO (X) `(CONS (CAR ,(CADR X)) (CDR ,(CADR X))))
(DEFUN COPYL MACRO (X) `(APPEND ,(CADR X) NIL))

(DEFUN >= MACRO (X) `(NOT (< ,(CADR X) ,(CADDR X))))
(DEFUN <= MACRO (X) `(NOT (> ,(CADR X) ,(CADDR X))))

(DEFUN ECONS MACRO (X) `(APPEND ,(CADR X) (LIST ,(CADDR X))))

(DEFUN CAAADAR MACRO (X) `(CAAADR (CAR ,(CADR X))))
(DEFUN CAAADDR MACRO (X) `(CAAADR (CDR ,(CADR X))))
(DEFUN CAADAAR MACRO (X) `(CAADAR (CAR ,(CADR X))))
(DEFUN CAADADR MACRO (X) `(CAADAR (CDR ,(CADR X))))
(DEFUN CADAAAR MACRO (X) `(CADAAR (CAR ,(CADR X))))
(DEFUN CADADDR MACRO (X) `(CADADR (CDR ,(CADR X))))
(DEFUN CADDAAR MACRO (X) `(CADDAR (CAR ,(CADR X))))
(DEFUN CADDADR MACRO (X) `(CADDAR (CDR ,(CADR X))))
(DEFUN CADDDAR MACRO (X) `(CADDDR (CAR ,(CADR X))))
(DEFUN CADDDDR MACRO (X) `(CADDDR (CDR ,(CADR X))))
(DEFUN CDADADR MACRO (X) `(CDADAR (CDR ,(CADR X))))
(DEFUN CDADDDR MACRO (X) `(CDADDR (CDR ,(CADR X))))
(DEFUN CDDDDDR MACRO (X) `(CDDDDR (CDR ,(CADR X))))


(DECLARE (SPECIAL NAME BAS MOBJECTS SELECTOR) (*EXPR MODE))


(SETQ MOBJECTS NIL)

(DEFPROP MODE (C-MODE S-MODE A-MODE) MODE)

(DEFUN C-MODE MACRO (X) `(LIST . ,(CDR X)))

(DEFUN S-MODE MACRO (X)
  (COND ((EQ 'C (CADDR X)) `(CAR ,(CADR X)))
	((EQ 'SEL (CADDR X)) `(CADR ,(CADR X)))
	((EQ '← (CADDR X)) `(CADDR ,(CADR X)))))

(DEFUN A-MODE MACRO (X)
  (COND ((EQ 'C (CADDR X)) `(RPLACA (CADR X) ,(CADDDR X)))
	((EQ 'SEL (CADDR X)) `(RPLACA (CDR ,(CADR X)) ,(CADDDR X)))
	((EQ '← (CADDR X)) `(RPLACA (CDDR ,(CADR X)) ,(CADDDR X)))))



(DEFUN DEFMODE MACRO (X)
  (LAMBIND ((SELECTOR (MEMQ 'SELECTOR (CDDDDR X))))
    (DEFINE-MODE (CADR X) (CADDDR X))
    (MAPC 'EVAL (CDDDDR X))
    `',(CADR X)))

(DEFUN DEFINE-MODE (NAME DESC)
  (PROG (C S A DUMMY)
    (SETQ DUMMY (EXPLODEC NAME)
	  C (IMPLODE (APPEND '(C -) DUMMY))
	  S (IMPLODE (APPEND '(S -) DUMMY))
	  A (IMPLODE (APPEND '(A -) DUMMY)))
    (DEFINE-MACRO C (DEFC DESC))
    (DEFINE-MACRO S (DEFS DESC))
    (DEFINE-MACRO A (DEFA DESC))
    (PUT NAME (C-MODE C S A) 'MODE)
    (RETURN NAME)))


(DEFUN DEFC (DESC) (LAMBIND ((BAS 'X)) `(LAMBDA (X) ,(DEFC1 DESC))))

(DEFUN DEFC1 (DESC)
  (COND ((ATOM DESC) (LIST 'QUOTE DESC))
	((EQ 'SELECTOR (CAR DESC))
	 (COND ((NOT (NULL (CDDDR DESC))) (LIST 'QUOTE (CADDDR DESC)))
	       (T (SETQ BAS (LIST 'CDR BAS))
		  (LIST 'CAR BAS))))
	((EQ 'ATOM (CAR DESC))
	 `(LIST 'C-ATOM '',(MAPCAR 'CADR (CDR DESC)) (CONS 'LIST (CDR X))))
	((EQ 'CONS (CAR DESC)) `(LIST 'CONS ,(DEFC1 (CADR DESC)) ,(DEFC1 (CADDR DESC))))
	((EQ 'LIST (CAR DESC))
	 (DO ((L (CDR DESC) (CDR L)) (NL))
	     ((NULL L) `(LIST 'LIST . ,(NREVERSE NL)))
	     (SETQ NL (CONS (DEFC1 (CAR L)) NL))))
	((EQ 'STRUCT (CAR DESC)) (DEFC1 (CONS 'LIST (CDR DESC))))
	(T (LIST 'QUOTE DESC))))


(DEFUN DEFS (DESC)
  `(LAMBDA (X) (COND . ,(NREVERSE (DEFS1 DESC '(CADR X) NIL)))))

(DEFUN DEFS1 (DESC BAS RESULT)
  (COND ((ATOM DESC) RESULT)
	((EQ 'SELECTOR (CAR DESC))
	 (PUT (CADR DESC) (CONS (CONS NAME (CADDR DESC)) (GET (CADR DESC) 'MODES)) 'MODES)
	 (PUT NAME (CONS (CONS (CADR DESC) (CADDR DESC)) (GET NAME 'SELS)) 'SELS)
	 (IF SELECTOR (DEFINE-MACRO (CADR DESC) 'SELECTOR))
	 (CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT))
	((EQ 'ATOM (CAR DESC))
	 (DO L (CDR DESC) (CDR L) (NULL L)
	     (PUT (CADAR L) (CONS (CONS NAME (CADDAR L)) (GET (CADAR L) 'MODES)) 'MODES)
	     (PUT NAME (CONS (CONS (CADAR L) (CADDAR L)) (GET NAME 'SELS)) 'SELS)
	     (IF SELECTOR (DEFINE-MACRO (CADAR L) 'SELECTOR)))
	 (CONS `((MEMQ (CADDR X) ',(MAPCAR 'CADR (CDR DESC))) (LIST 'GET ,BAS (LIST 'QUOTE (CADDR X))))
	       RESULT))
	((EQ 'CONS (CAR DESC))
	 (SETQ RESULT (DEFS1 (CADR DESC) `(LIST 'CAR ,BAS) RESULT))
	 (DEFS1 (CADDR DESC) `(LIST 'CDR ,BAS) RESULT))
	((EQ 'LIST (CAR DESC))
	 (DO L (CDR DESC) (CDR L) (NULL L)
	     (SETQ RESULT (DEFS1 (CAR L) `(LIST 'CAR ,BAS) RESULT)
		   BAS `(LIST 'CDR ,BAS)))
	 RESULT)
	((EQ 'STRUCT (CAR DESC)) (DEFS1 (CONS 'LIST (CDR DESC)) BAS RESULT))
	(T RESULT)))

(DEFUN DEFA (DESC)
  `(LAMBDA (X) (COND . ,(NREVERSE (DEFA1 DESC '(CADR X) NIL NIL)))))

(DEFUN DEFA1 (DESC BAS CDR RESULT)
  (COND ((ATOM DESC) RESULT)
	((EQ 'SELECTOR (CAR DESC))
	 (SETQ BAS (COND ((NOT CDR) `(LIST 'CAR (LIST 'RPLACA ,(CADDR BAS) (CADDDR X))))
			 (T `(LIST 'CDR (LIST 'RPLACD ,(CADDR BAS) (CADDDR X))))))
	 (CONS `((EQ ',(CADR DESC) (CADDR X)) ,BAS) RESULT))
	((EQ 'ATOM (CAR DESC))
	 (LIST `(T (LIST 'A-ATOM (CADR X) (LIST 'QUOTE (CADDR X)) (CADDDR X)))))
	((EQ 'CONS (CAR DESC))
	 (SETQ RESULT (DEFA1 (CADR DESC) `(LIST 'CAR ,BAS) NIL RESULT))
	 (DEFA1 (CADDR DESC) `(LIST 'CDR ,BAS) T RESULT))
	((EQ 'LIST (CAR DESC))
	 (DO L (CDR DESC) (CDR L) (NULL L)
	     (SETQ RESULT (DEFA1 (CAR L) `(LIST 'CAR ,BAS) NIL RESULT)
		   BAS `(LIST 'CDR ,BAS)))
	 RESULT)
	((EQ 'STRUCT (CAR DESC)) (DEFA1 (CONS 'LIST (CDR DESC)) BAS CDR RESULT))
	(T RESULT)))


(DEFUN MODE (X) (CDR (ASSOC X MOBJECTS)))

(DEFUN MODEDECLARE FEXPR (X)
  (MAPC '(LAMBDA (L) (MAPC '(LAMBDA (V) (SETQ MOBJECTS (CONS (CONS V (CAR L)) MOBJECTS)))
			   (CDR L)))
	X))

(DEFUN NDM-ERR (X)
  (TERPRI)
  (PRINC '|Cannot determine the mode of |) (PRINC X)
  (ERR))

(DEFUN NSM-ERR (X)
  (TERPRI)
  (PRINC '|No such mode as |) (PRINC X)
  (ERR))

(DEFUN SEL-ERR (B S)
  (TERPRI)
  (PRINC '/:) (PRINC B)
  (DO () ((NULL S)) (PRINC '/:) (PRINC (CAR S)) (SETQ S (CDR S)))
  (PRINC '|is an impossible selection|)
  (ERR))

(DEFUN IA-ERR (X)
  (TERPRI)
  (PRINC '|Cannot assign |) (PRINC X)
  (ERR))


(DEFUN SEL MACRO (X)
  (PROGB ((S (FSEL (MODE (CADR X)) (CDDR X))))
    (COND ((NULL S) (SEL-ERR (CADR X) (CDDR X)))
	  (T (SETQ X (CADR X))
	     (DO () ((NULL (CDR S)) X)
		 (SETQ X (CONS (CADR (GET (CAR S) 'MODE)) (RPLACA S X)) S (CDDR S))
		 (RPLACD (CDDR X) NIL))))))

(DEFUN FSEL (M SELS)		; This has a bug in it.
  (COND ((NULL SELS) (LIST M))
	((NULL M)
	 (DO L (GET (CAR SELS) 'MODES) (CDR L) (NULL L)
	     (IF (SETQ M (FSEL (CDAR L) (CDR SELS)))
		 (RETURN (CONS (CAAR L) (CONS (CAR SELS) M))))))
	((PROGB (DUM)
	   (IF (SETQ DUM (ASSQ (CAR SELS) (GET M 'SELS)))
	       (CONS M (CONS (CAR SELS) (FSEL (CDR DUM) (CDR SELS)))))))
	(T (DO ((L (GET M 'SELS) (CDR L)) (DUM)) ((NULL L))
	       (IF (SETQ DUM (FSEL (CDAR L) SELS))
		   (RETURN (CONS M (CONS (CAAR L) DUM))))))))

(DEFUN SELECTOR (X)
  (IF (NULL (CDDR X)) `(SEL ,(CADR X) ,(CAR X))
      `(← (SEL ,(CADR X) ,(CAR X)) ,(CADDR X))))


(DEFUN ← MACRO (X) `(STO . ,(CDR X)))

(DEFUN STO MACRO (X)
  (DO ((L (CDR X) (CDDR L)) (S) (NL))
      ((NULL L) `(PROGN . ,(NREVERSE NL)))
      (COND ((ATOM (CAR L)) (SETQ NL (CONS `(SETQ ,(CAR L) ,(CADR L)) NL)))
	    ((AND (EQ 'SEL (CAAR L)) (SETQ S (FSEL (MODE (CADAR L)) (CDDAR L))))
	     (SETQ X (CADAR L))
	     (DO L (CDDR S) (CDDR L) (NULL (CDR L))
		 (SETQ X (CONS (CADR (GET (CAR L) 'MODE)) (RPLACA L X)))
		 (RPLACD (CDDR X) NIL))
	     (SETQ NL (CONS (LIST (CADDR (GET (CAR S) 'MODE)) X (CADR S) (CADR L)) NL)))
	    (T (IA-ERR (CAR L))))))


(DEFUN C-ATOM (SELS ARGS)
  (DO ((NL)) ((NULL SELS) (RPLACD (INTERN (GENSYM)) (NREVERSE NL)))
      (IF (CAR ARGS) (SETQ NL (CONS (CAR ARGS) (CONS (CAR SELS) NL))))
      (SETQ SELS (CDR SELS) ARGS (CDR ARGS))))

(DEFUN A-ATOM (BAS SEL VAL)
  (COND ((NULL VAL) (REMPROP BAS SEL) NIL)
	(T (PUTPROP BAS VAL SEL))))

(DEFUN DSSQ (X L)
  (DO () ((NULL L))
      (COND ((EQ X (CDAR L)) (RETURN (CAR L))) (T (SETQ L (CDR L))))))

(defun returns macro (x)
  (cond ((null (cddr x)) `(return ,(cadr x)))
	(t (do ((l (cdr x) (cdr l)) (i 1 (1+ i)) (nl))
	       ((null l) `(setq . ,(nreverse nl)))
	     (setq nl (cons (car l) (cons (implode (nconc (exploden 'register)
							  (exploden i)))
					  nl)))))))

(defun setqs macro (x)
  (cond ((atom (cadr x)) `(setq ,(cadr x) ,(caddr x)))
	(t (do ((l (cadr x) (cdr l)) (i 1 (1+ i)) (nl))
	       ((null l) `(progn ,(caddr x) (setq . ,(nreverse nl))))
	     (setq nl (cons (implode (nconc (exploden 'register) (exploden i)))
			    (cons (car l) nl)))))))


(DEFUN IMPVAR MACRO (X) `(SPECIAL . ,(CDR X)))
(DEFUN EXPVAR MACRO (X) `(SPECIAL . ,(CDR X)))
(DEFUN IMPFUN MACRO (X) `(*EXPR . ,(CDR X)))
(DEFUN EXPFUN MACRO (X) `NIL)

(DEFUN SPLIT MACRO (X) `NIL)
(DEFUN UNSPLIT MACRO (X) `NIL)